COMMENT ⊗   VALID 00029 PAGES 
RECORD PAGE   DESCRIPTION
 00001 00001
 00004 00002	TITLE SALISP  -  SAIL Accessible LISP  -  November 1972.
 00005 00003	SAIL JOBDAT ADDRESSES.
 00006 00004	AC DEFINITIONS AND EXTERNALS 		--- PAGE 1
 00008 00005	ALTERNATE PDP-10 MNEMONICS.
 00009 00006	UUO definitions
 00012 00007	system UUOs
 00014 00008	ALLOCATION DIALOGUE SUBROUTINE.
 00017 00009	LISP TO SAIL.
 00018 00010	SAIL TO LISP.
 00020 00011	Compute size of Halfword Bit Table and Half Word Space.
 00022 00012	Initialize the values of the BPORG & BPEND atoms.
 00024 00013	Initialize the OBLIST in HWS.
 00025 00014	Relocate CAR of cell.
 00026 00015	Intern the atom on the OBLIST.
 00028 00016	TOP LEVEL AND INITIALIZATION  --- PAGE 2
 00030 00017	INITFN:	EXCH A,INITF#
 00031 00018	APR INTERRUPT ROUTINES --- PAGE 3
 00033 00019	UUO HANDLER AND SUBR CALL ROUTINES --- PAGE 4
 00035 00020		SKIPA T,TT
 00036 00021	ARGPDL:	LDB T,[POINT 4,JOBUUO,ACFLD]
 00037 00022	r←0 ←> compiler calling a -
 00039 00023	UUOS5:	CAR R,(T)
 00040 00024	ERROR HANDLER AND BACKTRACE --- PAGE 5
 00042 00025	subroutine to search oblist for closest function to address in r
 00044 00026	dispatcher for error message uuos
 00046 00027	ERROR2:	CDR A,JOBUUO
 00048 00028	error messages
 00049 00029	backtrace subroutine
 00052 ENDMK
⊗;
TITLE SALISP  -  SAIL Accessible LISP  -  November 1972.

;storage allocation map.

	orgLSP: . 	;LISP interpreter.
	sizLSP:	efolst-.-1
	endLSP: efolst-1

	orgBPS: 0	;Binary Program Space.
	sizBPS:	2000
	endBPS: 0
	
	orgHWS: 0	;Half Word Space.
	sizHWS:	0
	endHWS: 0

	orgFWS: 0	;Full Word Space.
	sizFWS:	1000
	endFWS: 0

	orgHBT: 0	;Halfwords Bit Tables.
	sizHBT:	0
	endHBT: 0

	orgFBT: 0	;Fullwords Bit Table
	sizFBT:	0
	endFBT: 0
	
	orgPDL: 0	;regular PDL.
	sizPDL:	1000
	endPDL: 0

	orgSPD: 0	;special PDL.
	sizSPD:	1000
	endSPD: 0
;SAIL JOBDAT ADDRESSES.

	SAI41:	0
	SAIAPR:	0

;SAIL ACCUMULATORS.
	for @' i←0,17{AC'i: 0↔}

;LISP ACCUMULATORS.

	LISPAC:	BLOCK 20

;Olde switch and pointers.

	RETFLG:	0
	BSFLG:	0	;Boot Strape initialization done.
SUBTTL AC DEFINITIONS AND EXTERNALS 		--- PAGE 1
	INUMIN←377777
	INUM0←<INUMIN+777777>/2
	BCKETS←←177

;accumulator definitions
;`sacred' means sacred to the interpreter
;`marked' means marked from by the garbage collector
;`protected' means protected during garbage collection

↓NIL←0	;sacred, marked, protected	;atom head of NIL
↓A←1	;marked, protected	;1st arg & function result.
↓B←A+1	;marked, protected	;second arg of subrs
↓C←B+1	;marked, protected	;third arg of subrs
↓AR1←4	;marked, protected	;fourth arg of subrs
↓AR2A←5	;marked, protected	;fifth arg of subrs
↓T←6	;marked, protected	;minus number of args in LSUBR call
↓TT←7	;marked, protected
↓REL←10	;marked, protected	;rarely used
↓S←11	;rarely used
↓D←12	
↓R←13	;protected
↓P←14	;sacred, protected	;regular push down stack pointer
↓F←15	;sacred	;free storage list pointer
↓FF←16	;sacred	;full word list pointer
↓SP←17	;sacred, protected	;special pushdown stack pointer

NACS←←5	;number of argument acs

X←←0	;X indicates impure (modified) code locations
TEN←←=10
;ALTERNATE PDP-10 MNEMONICS.

	OPDEF LIP[HLR]
	OPDEF LAP[HRR]
	OPDEF DIP[HRLM]
	OPDEF DAP[HRRM]
	
	OPDEF CAR[HLRZ]
	OPDEF CDR[HRRZ]
	OPDEF DIPZ[HRLZM]
	OPDEF DAPZ[HRRZM]

	OPDEF LAC[MOVE]
	OPDEF DAC[MOVEM]
	OPDEF LACN[MOVN]
	OPDEF DACN[MOVNM]

;The foolst macro marks LISP Space References.

	DEFINE FOO <
	XLIST
		BAZ(→FOOCNT)
	LIST
		>
	
	DEFINE BAZ '(X)
	<FOOCNT←FOOCNT+1
	FOO'X:
	>

	FOOCNT←0
;UUO definitions
;UUOs used to call functions from compiled code
;the number of arguments is given by the ac field 
;the address is a pointer either to the function 
;name or the code of the function

OPDEF FCALL [34B8]	;ordinary function call, like PUSHJ
OPDEF JCALL [35B8]	;terminal function call, like JRST
OPDEF CALLF [36B8]	;like call but may not be changed to PUSHJ
OPDEF JCALLF [37B8]	;like jcall but may not be changed to JRST

;error UUOs 

OPDEF ERR1 [1B8]	;ordinary lisp error	;gives backtrace
OPDEF ERR2 [2B8]	;space overflow error	;no backtrace
OPDEF ERR3 [3B8]	;ill. mem. ref.
OPDEF STRTIP [4B8]	;print error message and continue

;external and internal symbols

	EXTERNAL JOB41	;instruction to be executed on UUO
	EXTERNAL JOBAPR	;address of APR interupt routines
	EXTERNAL JOBCNI	;interupt condition flags
	EXTERNAL JOBFF	;first location beyond program
	EXTERNAL JOBREL	;top of core image.
	EXTERNAL JOBREN	;reentry address
	EXTERNAL JOBSA	;starting address
	EXTERNAL JOBSYM	;address of symbol table
	EXTERNAL JOBTPC	;program counter at time of interupt
	EXTERNAL JOBUUO	;uuo with its effective address.

;apr flags

	PDOV←←200000	;push down list overflow
	MPV←←20000	;memory protection violation
	NXM←←10000	;non-existant memory referenced
	APRFLG←←PDOV+MPV+NXM	;any of the above
	
;system uuos
	APRINI←←16
	RESET←←0
	STIME←←27
	DEVCHR←←4
	EXIT←←12
	CORE←←11
;system UUOs

	OPDEF TTYUUO [51B8]
	OPDEF INCHRW [TTYUUO 0,]
	OPDEF OUTCHR [TTYUUO 1,]
	OPDEF OUTSTR [TTYUUO 3,]
	OPDEF INCHWL [TTYUUO 4,]
	OPDEF INCHSL [TTYUUO 5,]
	OPDEF CLRBFI [TTYUUO 11,]
	DEFINE TALK{PUSHJ P,TTYCLR}

;I/O bits and constants

	TTYLL←←105	;teletype linelength 
	LPTLL←←160	;line printer linelength
	MLIOB←←203	;max length of I/O buffer
	NIOB←←2	;no of I/O buffers per device
	NIOCH←←7	;number of I/O channels
	FSTCH←←11	;first I/O channel
	TTCH←←10	;teletype I/O channel
	COUNT←←10
	BLKSIZE←←NIOB*MLIOB+COUNT+1
	INB←←2
	OUTB←←1
	AVLB←←40
	DIRB←←4

;special ASCII characters
	ALTMOD←←175
	SPACE←←40	;space
	IGCRLF←←32	;ignored cr-lf
	RUBOUT←←177
	LF←←12
	CR←←15
	TAB←←11
	BELL←←7
	DBLQT←←42	;double quote "

;byte pointer field definitions
	ACFLD←←14	;ac field
	XFLD←←21	;index field
	OPFLD←←10	;opcode field
	ADRFLD←←43	;adress field
	
;ALLOCATION DIALOGUE SUBROUTINE.

ALLOCD:	0

OUTSTR [ASCIZ /
ALLOC? /]
	INCHRW C
	CAIGE C,"O"
	JRST @ALLOCD

OUTSTR [ASCIZ /
FULL WDS=/]
	JSR ALLNUM
	SKIPGE A
	MOVEI A,400
	DAC A,sizFWS

OUTSTR [ASCIZ /
BIN.PROG.SP=/]
	JSR ALLNUM
	SKIPGE A
	MOVEI A,2000
	DAC A,sizBPS

OUTSTR [ASCIZ /
SPEC.PDL=/]
	JSR ALLNUM
	SKIPGE A
	MOVEI A,1000
	DAC A,sizSPD

OUTSTR [ASCIZ /REG. PDL=
/]
	JSR ALLNUM
	SKIPGE A
	MOVEI A,1000
	DAC A,sizPDL
	JRST @ALLOCD

ALLNUM:	0
	MOVSI A,400000		;high bit on for no digits
	INCHRW C
	CAIN C,RUBOUT
	JRST	[OUTSTR [ASCIZ /XXX /]
		JRST ALLNUM+1]
	CAIL C,"0"
	CAILE C,"9"
	JRST @ALLNUM
	TLZ A,400000	;turn off hi bit on digit
	IMULI A,10
	ADDI A,-"0"(C)
	JRST ALLNUM+2
;LISP TO SAIL.
INTERN SAIL
SAIL:	LAC SAI41
	DAC JOB41
	LAC SAIAPR
	DAC JOBAPR
	LAC 0,[XWD AC1,1]
	BLT 0,17
	LAC 0,AC0
	SUB 17,[XWD 2,2]
	JRST @2(17)
;SAIL TO LISP.
	INTERN LISP
	EXTERN CORGET
;ACCUMULATOR-2	POINTER TO FIRST WORD OF SAIL MEMORY BLOCK.
;ACCUMULATOR-3  SIZE OF SAIL MEMORY BLOCK.
LISP:	DAC 0,AC0
	LAC 0,[XWD 1,AC1]
	BLT 0,AC17
	LAC 3,-1(17)
	PUSHJ 17,CORGET
	JFCL
;JSR ALLOCD ;Allocation dialogue.
OUTSTR [ASCIZ/
/]
	
;Bottom, Size & Top of LISP memory space.
	lac B,2↔lac S,3↔lac T,B
	addi T,-1(S)
	movei 1(B)↔dip B,0↔setzm(B)↔blt(T)

;Take BPS off the bottom
	dac B,orgBPS
	add B,sizBPS
	dac B,endBPS
	sos   endBPS
	sub S,sizBPS

;Take SPD off the top.
	dac T,endSPD
	sub T,sizSPD
	dac T,orgSPD
	aos   orgSPD
	sub S,sizSPD

;Compute FWS size ← 400+S/16.
	lac  A,S
	ash  A,-4
	addb A,sizFWS

;Compute FBT size.
	idivi A,44
	addi A,2
	dac A,sizFBT

;Compute PDL size.
	lac A,S
	ash A,-6
	addm A,sizPDL
;Compute size of Halfword Bit Table and Half Word Space.

	sub S,sizFBT
	sub S,sizFWS
	sub S,sizPDL
	lac A,S
	idivi A,41
	addi A,2  ;fractional words possible fore and aft.
	dac A,sizHBT
	sub S,A
	dac S,sizHWS

;Take Half Word Space, HWS, off the bottom.

	lac T,endBPS
	movei B,1(T)
	dac B,orgHWS
	add B,sizHWS
	add T,sizHWS
	dac T,endHWS

;allocate Full Word Space, FWS above HWS.

	dac B,orgFWS
	add B,sizFWS
	add T,sizFWS
	dac T,endFWS
	
;allocate Halfword Bit Table, HBT above FWS.

	dac B,orgHBT
	add B,sizHBT
	add T,sizHBT
	dac T,endHBT
	
;allocate Fullword Bit Table, FBT above HBT.

	dac B,orgFBT
	add B,sizFBT
	add T,sizFBT
	dac T,endFBT
	
;allocate Push Down List, PDL above FBT.

	dac B,orgPDL
	add B,sizPDL
	add T,sizPDL
	dac T,endPDL
;Initialize the values of the BPORG & BPEND atoms.

	LAC A,orgBPS
	ADDM A,VBPORG	;value of BPORG.
	LAC A,endBPS
	ADDM A,VBPEND	;value of BPEND.

;Setup Special PDL pointer.

	LACN A,SIZSPD
	hrlz A,A
	lap A,orgSPD
	sos A
	dac A,SC2

;lowest word of PDL holds pointer to OBLIST.

	LAC B,orgPDL
	LAC A,orgHWS
	DAC A,(B)

;setup regular PDL pointer.

	ADDI B,12
	DAP B,C2
	LACN C,SIZPDL
	ADDI C,20
	DIP C,C2

;Fixup references to HWS.

	lac FF,orgHWS
	addi FF,bckets  ;ATOMS'.
	subi FF,ATOMS
	MOVEI C,FOOLST
REL5:	LAC B,(C)↔ CDR A,(B)↔ ADD A,FF↔ DAP A,(B)
	LIP B, B ↔ CDR A,(B)↔ ADD A,FF↔	DAP A,(B)
	CAIGE C,EFOLST-1
	AOJA C,REL5
;Initialize the OBLIST in HWS.

	hrlzi A,1-bckets
	lap   A,orgHWS
	aos   A
	dapz  A,-1(A)
	aobjn A,.-1

;Initialize pointers for atomic relocation.

	movei F,ATOMS+2		;From here.
	lac T,orgHWS
	addi T,bckets+2		;To there
	lac  TT,endHWS		;Top To there.
FOO	hrli TT,PNAME		;PNAME property.
	lac  FF,orgFWS		;pname full words.
	lac REL,T↔sub REL,F	;relocation displacement.

;Save pointer to Atom Head for OBLIST interning.
	tdza S,S   ;The first atom is NIL.
REL0:	lac S,T

;Relocate CAR of cell.

REL1:	car A,(F)	;get From atoms.
	caige A,ATOME	;skip too high.
	caige A,ATOMS	;step too low.
	skipa		;not in HWS.
	add A,REL
	dip A,(T)

;Relocate CDR of cell.

	cdr A,(F)
	caige A,ATOME
	caige A,ATOMS
	skipa
	add A,REL
	dap A,(T)

;Advance down property list.

	aos F ↔ aos T	;advance pointers in Sync.
	jumpn A,REL1	;test for end of list.
;Intern the atom on the OBLIST.

	lac A,(F)	;get 1st word of pname.
	lsh A,-1
	idivi A,bckets
	add B,orgHWS	;bucket pointer.
	car A,(B)
FOO	cain S,UNBOUND
	jrst .+5 	; Don't intern UNBOUND.
	dip TT,(B)	;put a node in the bucket.
	dap A,(TT)
	dip S,(TT)	;put atom head in the node.
	sos TT		;new top of HWS.

;Take two words off the top of HWS for PNAME property pair.

	dipz T,(TT)	;(pnlist . NIL)
	dac  TT,-1(TT)	;(PNAME . (pnlist . NIL))
	sos TT
	dap TT,-1(T)	;NCONC pname pair on property list.
	sosa TT		;new top of HWS and Skip.

;Make pname Full Word List.

REL2:	dap T,-1(T)		;PNAME list continued.
	lac(F)↔dac(FF)
	dipz FF,(T)		;put FW pointer in list.
	aos F ↔ aos T ↔ aos FF	;advance pointers in Sync.
	hlre(F)↔aose		;test for atom head, End of Ascii.
	jrst REL2

;Mark end of PNLIST.

	caige F,ATOME	;End of Atoms.
	jrst REL0
	setzb F,DDTIFG
	jsr IOBRST
	jrst START
SUBTTL TOP LEVEL AND INITIALIZATION  --- PAGE 2

START:  ;CALLI RESET
	LAC  [JSR UUOH]
	EXCH JOB41
	MOVEM SAI41
	MOVEI APRINT
	EXCH  JOBAPR
	DAC   SAIAPR
	MOVEI APRFLG
	CALLI APRINI
	HRRZI 17,1
	SETZB 0,PSAV1
	BLT 17,17	;clear acs 
LSPRT1:	SETOM ERRSW	;print error messages
	SETZM ERRTN	;return to top level on errors
	SETOM PRVCNT#	;initialize counter for errio
	MOVE P,C2#	;initial reg pdl ptr
	MOVE SP,SC2#	;initial spec pdl ptr
LISP1X:	PUSHJ P,TTYRET	;(outc nil t)(inc nil t).
FOO	HRROI 0,CNIL2	;initialize nil
	SKIPN FF+X	
	PUSHJ P,AGC	;garbage collect only if necessary
	SKIPN BSFLG#	;initial bootstrap for macros
	JRST BOOTS
	;SKIPE RETFLG	;test for error return
	;JRST [	SKIPE A,INITF
	;	CALLF (A)	;evaluate initialization function
	;	SETZM RETFLG
	;	JRST .+1]
LISP2:	PUSHJ P,TTYRET		;return all i/o to tty
	PUSHJ P,TERPRI
	SKIPE GOBF#	;garbaged oblist flag
	STRTIP [SIXBIT /GARBAGED OBLIST←!/]
	SETZM GOBF
	SKIPE BPSFLG#
	JRST BINER2	;binary program space exceeded by loader
LISP1:	PUSHJ P,READ	;this is the top level of lisp
	PUSHJ P,EVAL
	PUSHJ P,PRINT
	PUSHJ P,TERPRI
	JRST LISP1
INITFN:	EXCH A,INITF#
	POPJ P,

;return from lisp error or bell
LSPRET:	PUSHJ P,TERPRI
	SKIPE PSAV1#	;bell from alvine?
	JRST [	MOVE P,PSAV1	;yes, return to alvine
		CDR REL,ED
		JRST 1(REL)]	;improved magic
	MOVE B,SC2
	PUSHJ P,UBD	;unbind specpdl
	SETOM RETFLG	;set return flag
	JRST LSPRT1

.RSET:	EXCH A,RSTSW#
	POPJ P,

;bootstrapper for macro definitions
BOOTS:	SETOM BSFLG
	MOVEI A,BSTYI
	PUSHJ P,READP1
	PUSHJ P,EVAL
	PUSHJ P,READ
	JRST .-2

BSTYI:	ILDB A,[POINT 7,[ASCII /(INC(INPUT SYS:(LISP.LSP)))/]]
	POPJ P,
SUBTTL APR INTERRUPT ROUTINES --- PAGE 3
;arithmetic processor interupts
;mem. protect. violation, nonex. mem. or pdl overflow

APRINT:	MOVE R,JOBCNI	;get interupt bits
	TRNE R,MPV+NXM	;what kind
	ERR3 @JOBTPC	;an ill mem ref-will become JRST ILLMEM
	JUMPN NIL,MES21	;a pdl overflow
	STRTIP [SIXBIT /←PDL OVERFLOW FROM GC - CAN'T CONTINUE!/]
	JRST START

MES21:	SETZM JOBUUO
	SKIPL P
	STRTIP [SIXBIT /←REG !/]
	SKIPL SP
	STRTIP [SIXBIT /←SPEC !/]
	SKIPE JOBUUO
SPDLOV:	ERR2 [SIXBIT /PUSHDOWN CAPACITY EXCEEDED !/]
	TRNE R,PDOV
	SKIPE JOBUUO
	HALT		;lisp should not be here
BINER2:	SETZM BPSFLG
	ERR2 [SIXBIT /BINARY PROGRAM SPACE EXCEEDED !/]

ILLMEM:	LDB R,[POINT 4,@JOBTPC,XFLD];get index field of bad word
	CAIE R,F	;does  it contain f
	ERR3 @JOBTPC	;no! error
	PUSHJ P,AGC	;yes! garbage collect
	JRST @JOBTPC	;and continue
SUBTTL UUO HANDLER AND SUBR CALL ROUTINES --- PAGE 4

UUOMIN←←1
UUOMAX←←4

UUOH:	X		;jsr location
	MOVEM T,TSV#
	MOVEM TT,TTSV#
		LDB T,[POINT 9,JOBUUO,OPFLD]	;get opcode
	CAIGE T,34	;is it a function call
	JRST ERROR	;or a LISP error
	HLRE R,@JOBUUO
	AOJN R,UUOS
	LDB T,[POINT 4,JOBUUO,ACFLD]
	CAILE T,15
	MOVEI R,-15(T)
	CDR T,@JOBUUO
UUOH1:	CAR TT,(T)
	CDR T,(T)
FOO	CAIN TT,SUBR
	JRST @UUST(R)
FOO	CAIN TT,FSUBR
	JRST @UUFST(R)
FOO	CAIN TT,LSUBR
	JRST @UULT(R)
FOO	CAIN TT,EXPR
	JRST @UUET(R)
FOO	CAIN TT,FEXPR
	JRST @UUFET(R)
	CDR T,(T)
	JUMPN T,UUOH1
	PUSH P,A
	PUSH P,B
	CDR A,JOBUUO
FOO	MOVEI B,VALUE
	PUSHJ P,GET
	JUMPN A,[	CDR TT,(A)
			POP P,B
			POP P,A
			JRST UUOEX1]
	CDR A,JOBUUO
	PUSHJ P,EPRINT
	ERR1 [SIXBIT /UNDEFINED UUO!/]
	SKIPA T,TT
UUOSBR:	CAR T,(T)
	MOVE TT,JOBUUO
	HRLI T,(<PUSHJ P,>)
	TLNE TT,1000	;1000 means no push
	TLCA T,34600	;<PUSHJ P,>xor<JRST>
	PUSH P,UUOH
	SOS UUOH
UUOCL:	TLNN TT,2000+X	;2000 means no clobber
	MOVEM T,@UUOH
	MOVE TT,TTSV
	EXCH T,TSV
	JRST @TSV

UUOS:	CDR TT,JOBUUO
	CAMLE TT,orgHWS
	CAML TT,orgFWS
	JRST UUOSBR-1
	JRST .+2
UUOEXP:	CAR TT,(T)
UUOEX1:	LDB T,[POINT 5,JOBUUO,ACFLD]
	TRZN T,20
	PUSH P,UUOH
	PUSH P,TT
	JUMPE T,IAPPLY
	CAIN T,17
	MOVEI T,1
	MOVNS T
	HRLZ TT,T
	PUSH P,A(TT)
	AOBJN TT,.-1
	JRST IAPPLY
ARGPDL:	LDB T,[POINT 4,JOBUUO,ACFLD]
	MOVNS T
	HRLZ R,T
ARGP1:	JUMPE R,(TT)
	PUSH P,A(R)
	AOBJN R,.-1
	JRST (TT)

QTIFY:	PUSHJ P,NCONS
FOO	MOVEI B,CQUOTE
	JRST XCONS

QTLFY:	MOVEI A,0
QTLFY1:	JUMPE T,(TT)
	EXCH A,(P)
	PUSHJ P,QTIFY
	POP P,B
	PUSHJ P,CONS
	AOJA T,QTLFY1

PDLARG:	JRST .+NACS+2(T)
	POP P,A+5
	POP P,A+4
	POP P,A+3
	POP P,A+2
	POP P,A+1
	POP P,A
	JRST (TT)

NOUUO:	MOVSI B,(<TLNN TT,>)
	SKIPE A
	MOVSI B,(<TLNA>)
	HLLM B,UUOCL
	EXCH A,NOUUOF#
	POPJ P,
;r←0 ←> compiler calling a -
;r←1 ←> compiler calling a lsubr
;r←2 ←> compiler calling f type
UUST:	UUOSBR
	UUOS1	;calling l its a subr
	UUOS2	;calling f


UUFST:	UUOS9	;calling - its a f
	UUOS10	;calling l
	UUOSBR

UULT:	UUOS7	;calling - its a l
	UUOSBR
	UUOS8

UUET:	UUOEXP
	UUOS5	;calling l its an expr
	UUOS6	;calling f its an expr

UUFET:	UUOS3	;calling - its a fexpr
	UUOS4	;calling l
	UUOEXP	

UUOS1:	CAR R,(T)
	MOVE T,TSV
	JSP TT,PDLARG
	JRST (R)

UUOS3:	PUSH P,(T)
	JSP TT,ARGPDL
UUOS4A:	JSP TT,QTLFY
	MOVEI TT,1
	DPB TT,[POINT 4,JOBUUO,ACFLD]
UUOS6A:	POP P,TT
	HLRZS TT
	JRST UUOEX1

UUOS4:	PUSH P,(T)
	MOVE T,TSV
	JRST UUOS4A
UUOS5:	CAR R,(T)
	MOVE T,TSV
	JSP TT,PDLARG
	MOVE TT,R
	JRST UUOEX1

UUOS6:	PUSH P,(T)
	PUSH P,UUOH
	PUSH P,JOBUUO
	JSP TT,ILIST
	JSP TT,PDLARG
	POP P,JOBUUO
	POP P,UUOH
	JRST UUOS6A
UUOS8:	SKIPA TT,CILIST
UUOS7:	MOVEI TT,ARGPDL
	DAP TT,UUOS7A
	MOVE TT,JOBUUO
	TLNN TT,1000
	PUSH P,UUOH
	CAR TT,(T)
UUOS7A:	JRST ARGPDL+X	;or ilist

UUOS9:	PUSH P,T
	JSP TT,ARGPDL
UUS10A:	JSP TT,QTLFY
	MOVSI T,2000
	IORM T,JOBUUO
	POP P,T
	JRST UUOSBR

UUOS10:	PUSH P,T
	MOVE T,TSV
	JRST UUS10A

SUBTTL ERROR HANDLER AND BACKTRACE --- PAGE 5
;subroutine to print sixbit error message
ERRSUB:	MOVSI A,(<POINT 6,0>)
	HRR A,JOBUUO
	MOVEM A,ERRPTR#
ERRORB:	ILDB A,ERRPTR
	CAIN A,01	;conversion from sixbit
	POPJ P,
	CAIN A,77
	JRST [	PUSHJ P,TERPRI
		JRST ERRORB]
	ADDI A,40
	PUSHJ P,TYO
	JRST ERRORB

;subroutine to return output to previously selected device
OUTRET:	SKIPL PRVCNT	;if prvcnt<0 then no device deselect.
	SOSL PRVCNT	;when prvcnt goes negative, then reselect
	POPJ P,
	PUSH P,PRVSEL#		;previously selected output
	POP P,TYOD
	POPJ P,

;subroutine to force error messages out on tty
ERRIO:	MOVE B,ERRSW
	CAIE B,INUM0	;INUM0 means use selected device.
	AOSLE PRVCNT	;if prvcnt<0 then deselect.
	POPJ P,	
	TALK		;undo control o
	MOVE B,[JRST TTYO]
	EXCH B,TYOD
	MOVEM B,PRVSEL
	POPJ P,

ERRTN:	0	;0 ←> top level				*
	;- ←> pdl to reset to - stored by errorset
	;+ ←> string tyo pout rtn flag
ERRSW:	-1	;0 means no prnt on error		*
;subroutine to search oblist for closest function to address in r
ERSUB3:
FOO	MOVEI A,QST
FOO	HRROI NIL,CNIL2
	HRLZI B,BCKETS
	MOVNS B
	LAP   B,orgHWS
	SETZB AR2A,GOBF
	PUSH P,JOBAPR
	MOVEI C,[	SETOM GOBF
			JRST ERRO2G]
	DAP C,JOBAPR
	CAR C,(B)
ERRO2B:	JUMPE C,[	AOBJN B,.-1
			POP P,JOBAPR	;oblist done, restore
			JRST PRINC]	;print closest match
	CAR TT,(C)
ERRO2C:	CDR TT,(TT)
	JUMPE TT,ERRO2G
	CAR AR1,(TT)
FOO	CAIN AR1,LSUBR
	JRST ERRO2H
FOO	CAIE AR1,SUBR
FOO	CAIN AR1,FSUBR
	JRST ERRO2H
	CDR TT,(TT)
	JRST ERRO2C

ERRO2H:	CDR TT,(TT)
	CAR TT,(TT)
	CAMLE TT,AR2A	;le to prefer car to quote
	CAMLE TT,R
	JRST ERRO2G
	MOVE AR2A,TT
	CAR A,(C)
ERRO2G:	CDR C,(C)
	JRST ERRO2B
;dispatcher for error message uuos
ERROR:	MOVEI A,APRFLG
	CALLI A,APRINI	;enable interupts
	LDB A,[POINT 9,JOBUUO,OPFLD]	;get opcode
	CAIL A,UUOMIN	;what
	CAILE A,UUOMAX	;is it?
	JRST ILLUUO	;an illegal opcode
	JRST @ERRTAB-UUOMIN(A)	;or LISP error
ERRTAB:	ERROR1	;1	;ordinary LISP error
	ERRORG	;2	;space overflow error
	ERROR2	;3	;ill. mem. ref.
	STRTYP	;4	;print error message and continue
ERRORG:	SKIPN P,ERRTN	;if in errset, restore p to that level
	MOVE P,C2	;else to top level
			;and attempt to print message

ERROR1:	SKIPN ERRSW
	JRST ERREND	;dont print message, call (err nil)
	PUSHJ P,ERRIO	;print message on tty
	PUSHJ P,TERPRI
	PUSHJ P,ERRSUB	;print the message
	JRST ERRBK	;go the backtrace

STRTYP:	PUSHJ P,ERRIO
	PUSHJ P,ERRSUB	;print message and continue
	PUSHJ P,OUTRET
	JRST @UUOH
ERROR2:	CDR A,JOBUUO
	MOVEI B,[SIXBIT / ILL MEM REF FROM !/]
	JRST ERSUB2

ILLUUO:	CDR A,UUOH
	MOVEI B,[SIXBIT / ILL UUO FROM !/]
ERSUB2:	SKIPN ERRSW
	JRST ERREND	;dont print message
	PUSH P,A
	PUSH P,B
	PUSHJ P,ERRIO
	PUSHJ P,TERPRI
	PUSHJ P,PRINL2	;print number
	POP P,A
	STRTIP (A)	;print message
	POP P,R
	PUSHJ P,ERSUB3	;print nearest oblist match
ERRBK:	SKIPE BACTRF#
	PUSHJ P,BKTRC	;print backtrace
	PUSHJ P,OUTRET	;return to previous device
ERREND:	MOVEI A,0	;(err nil)
	SKIPN ERRTN
	JRST	[CLRBFI	;clear INPUT buffer
		SKIPE RSTSW
		JRST LISP2  ;(*rset t) goes to 
		 ;read-eval-print loop without unbinding.
		JRST LSPRET]	;unbind and go to top level
ERR:	SKIPN ERRTN
	JRST LSPRET ;not in an errset, or bad error -
			; - go to top level
	MOVE P,ERRTN
ERR1:	POP P,B
	PUSHJ P,UBD	;unbind to previous errset
	POP P,ERRSW
	POP P,ERRTN
	JRST ERRP4	;and proceed

ERRSET:	PUSH P,PA3
	PUSH P,PA4
	PUSH P,ERRTN
	PUSH P,ERRSW
	PUSH P,SP
	MOVEM P,ERRTN
	CDR C,(A)
	CAR C,(C)
	MOVEM C,ERRSW
	CAR A,(A)
	PUSHJ P,EVAL
	PUSHJ P,NCONS
	JRST ERR1
;error messages

DOTERR:	SETZM OLDCH
	ERR1 [	SIXBIT /DOT CONTEXT ERROR!/]
UNDFUN:	CAR A,(AR1)
	PUSHJ P,EPRINT
	ERR1 [SIXBIT /UNDEFINED FUNCTION!/]
UNBVAR:	PUSHJ P,EPRINT
	ERR1 [SIXBIT /UNBOUND VARIABLE - EVAL!/]
NONNUM:	ERR1 [SIXBIT /NON-NUMERIC ARGUMENT!/]
NOPNAM:	ERR1 [SIXBIT /NO PRINT NAME - INTERN!/]
NOLIST:	ERR1 [SIXBIT /NO LIST-MAKNAM!/]
TOMANY:	ERR1 [SIXBIT /TOO MANY ARGUMENTS SUPPLIED - APPLY!/]
TOOFEW:	ERR1 [SIXBIT /TOO FEW ARGUMENTS SUPPLIED - APPLY!/]
UNDTAG:	PUSHJ P,EPRINT
	ERR1 [SIXBIT /UNDEFINED FUNCTION - APPLY!/]
EG1:	CDR A,T
	PUSHJ P,EPRINT
	ERR1 [SIXBIT /UNDEFINED PROG TAG-GO!/]
;backtrace subroutine
BKTRC:	MOVEI D,-1(P)
	MOVN A,BACTRF
	ADDI A,INUM0
	JUMPL A,[	ADD A,P	;backtrace specific number 
			JRST .+3]
	SKIPN A,ERRTN	;backtrace to previous errset
	MOVE A,C2	;or top level
	DAPZ A,BAKLEV#
	STRTIP [SIXBIT /←BACKTRACE←!/]
BKTR2:	CAMG D,BAKLEV
	JRST FALSE	;done 
	CDR A,(D)	;get pdl element
	CAMGE A,orgHWS
	JUMPN A,.+2	;this is (hopefully) a true program address
	SOJA D,BKTR2	;not a program address, continue
	CAIN A,ILIST3
	JRST BKTR1A	;argument evaluation 
BKTR1B:	CAIN A,CPOPJ
	JRST [	CAR A,(D)	;calling a function
		PUSHJ P,PRINC
		XCT "-",CTY
		STRTIP [SIXBIT /ENTER !/]
		SOJA D,BKTR2]
	CAR B,-1(A)
	CAILE B,(<JCALLF 17,@(17)>)
	CAIN B,(<PUSHJ P,>)	;tests for various types of calls
	CAIGE B,(<FCALL>)
	SOJA D,BKTR2		;not a proper function call
	PUSH P,-1(A)	;save object of function call
	MOVEI R,-1(A)	;location of function call
	PUSHJ P,ERSUB3		;print closest oblist match
	MOVEI A,"-"
	PUSHJ P,TYO
	POP P,R
	TLNE R,17
	CDR R,ERSUB3	;qst -- cant handle indexed calls
	HRRZS R
	HLRO B,(R)
	AOSN B
	JRST [	CDR A,R	;was calling an atomic function
		PUSHJ P,PRINC	;print its name
		JRST .+2]
	PUSHJ P,ERSUB3	;was calling a code location -
			; - print closest match
	MOVEI A," "
	PUSHJ P,TYO
BKTR1:	SOJA D,BKTR2	;continue

BKTR1A:	CDR B,-1(D)
	CAIE B,EXP2
	CAIN B,ESB1
	JRST .+2
	JRST BKTR1B	;hum, not really evaluating arguments
	HLRE B,-1(D)
	ADD B,D
	CAR A,-3(B)
	JUMPE A,BKTR1
	PUSHJ P,PRINC
	XCT "-",CTY
	STRTIP [SIXBIT /EVALARGS !/]
	JRST BKTR1

BAKGAG:	EXCH A,BACTRF
	POPJ P,